Shareware Grab Bag/Shareware Grab Bag.iso/090/wheels1.arc/GTSETDIR.LIB

Text File | 1985-06-28 | 2KB | 51 lines

{@@@@@@@@@@@ copyright (C) 1984 by Neil J. Rubenking @@@@@@@@@@@@@@@@@@@@@@@@
The purchaser of these procedures and functions may include them in COMPILED
programs freely, but may not sell or give away the source text.

      Any program that INCLUDES GtSetDir MUST include FILENAME.TYP
      and REGPACK.TYP

      (This is in order to avoid multiple declarations)
}
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}
procedure GetSetDirectory(activity      : char;
                          VAR drive     : char;
                          VAR directory : filename_type;
                          VAR error     : byte);

var
  registers : regpack;
begin
  activity := upCase(activity);
  with registers do
    begin
      case activity of
        'G': begin
               DX := ord(UpCase(drive))-64;
               DS := seg(directory);
               SI := ofs(directory)+1;
               AX := $47 shl 8;
             end;
        'S': begin
               directory[length(directory)+1] := #0;
               DS := seg(directory);
               DX := ofs(directory)+1;
               AX := $3B shl 8;
             end;
      end; {case}
      MSDOS(registers);
      if Flags and 1 = 1 then
        error := AX and $00FF
      else
        begin
          error := 0;
          if activity = 'G' then
            begin
              directory := copy(directory,1,pos(#0,directory)-1);
              directory := drive + ':\' + directory;
            end;
        end;
    end;  {with}
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@}